home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / xscm.lha / xscm / xftp.scm < prev    next >
Encoding:
Text File  |  1992-08-29  |  4.5 KB  |  147 lines
  1. #! /usr/local/bin/xmscm
  2. ; $Header: /home/campbell/Languages/Scheme/scm/x-scm/RCS/xftp.scm,v 1.4 1992/08/12 01:57:29 campbell Beta $
  3. ;
  4. ; Sample X-scheme program for requesting files or RFCs from an FTP
  5. ; mail server.  It pops up a dialog in which you fill in the host
  6. ; name, filename, RFC number, etc. and then mails off a request.
  7. ; I wrote this partly to play with X-scheme and partly so I wouldn't
  8. ; have to remember the magic incantations for the FTP mail server.
  9. ;
  10. ; Author: Larry Campbell (campbell@redsox.bsw.com)
  11. ;
  12. (require 'stdio)
  13. (require 'x11)
  14. (require 'xt)
  15. (require 'xm)
  16. (require 'xmsubs)
  17.  
  18. ; Mail request to ftpmail@decwrl.dec.com and to the user
  19. ;
  20. (define request-destination
  21.   (string-append "ftpmail@decwrl.dec.com " (getenv "USER")))
  22.  
  23. ; Send an email request to the DECWRL FTP server to fetch a file,
  24. ; or get a directory listing, or both.
  25. ;
  26. (define (send-ftp-request host file dir)
  27.   (let* ((tmpfilename (tmpnam))
  28.      (tmpfile (open-output-file tmpfilename)))
  29.     (fprintf tmpfile "connect %s\\n" host)
  30.     (fprintf tmpfile "binary\\n")
  31.     (fprintf tmpfile "uuencode\\n")
  32.     (if (> (string-length file) 0)
  33.     (fprintf tmpfile "get %s\\n" file))
  34.     (if (> (string-length dir) 0)
  35.     (fprintf tmpfile "ls %s\\n" dir))
  36.     (fprintf tmpfile "quit")
  37.     (close-output-port tmpfile)
  38.     (let* ((s (make-string 80 #\space))
  39.        (len
  40.         (sprintf
  41.          s "elm -s request %s <%s" request-destination tmpfilename)))
  42.       (system (substring s 0 len))
  43.       (delete-file tmpfilename))))
  44.  
  45. ; Send an email request to the DECWRL FTP server to fetch an RFC
  46. ;
  47. (define (send-rfc-request rfc-number)
  48.   (let* ((tmpfilename (tmpnam))
  49.      (tmpfile (open-output-file tmpfilename)))
  50.     (fprintf tmpfile "connect gatekeeper.dec.com\\n")
  51.     (fprintf tmpfile "binary\\n")
  52.     (fprintf tmpfile "uuencode\\n")
  53.     (fprintf tmpfile "get /pub/net/info/RFC/rfc%d.txt\\n" rfc-number)
  54.     (fprintf tmpfile "quit")
  55.     (close-output-port tmpfile)
  56.     (let* ((s (make-string 80 #\space))
  57.        (slen
  58.         (sprintf
  59.          s "elm -s request %s <%s" request-destination tmpfilename)))
  60.       (system (substring s 0 slen))
  61.       (delete-file tmpfilename))))
  62.  
  63. (define top-level
  64.   (if (defined? vs:top-level)
  65.       (xt:app-create-shell "xftp" "Xftp"
  66.                xt:application-shell
  67.                (xt:display vs:top-level))
  68.       (xt:initialize "xftp" "Xftp")))
  69.  
  70. (xt:set-values
  71.  top-level
  72.  xt:n-allow-shell-resize #t
  73.  xt:n-title "FTP mail server requestor")
  74.  
  75. (define ftp-panel
  76.   (xt:create-managed-widget
  77.    "ftppanel" xm:row-column top-level))
  78.  
  79. (define ftp-host-widget
  80.   (make-captioned-text-widget ftp-panel "Host:" 30))
  81. (define ftp-file-widget
  82.   (make-captioned-text-widget ftp-panel "File to retrieve:" 30))
  83. (define ftp-dir-widget
  84.   (make-captioned-text-widget ftp-panel "Directory to list:" 30))
  85.  
  86. (xt:create-managed-widget "separator" xm:separator ftp-panel)
  87.  
  88. (define rfc-number-widget
  89.   (make-captioned-text-widget ftp-panel "RFC number:" 30))
  90.  
  91. (xt:create-managed-widget "separator" xm:separator ftp-panel)
  92.  
  93. (make-button-row
  94.  ftp-panel
  95.  `(
  96.    ("OK" ,(lambda (w)
  97.         (let* ((host (xm:text-get-string ftp-host-widget))
  98.            (file (xm:text-get-string ftp-file-widget))
  99.            (dir  (xm:text-get-string ftp-dir-widget))
  100.            (rfc  (xm:text-get-string rfc-number-widget)))
  101.           (if (and (not (zero? (string-length host)))
  102.                (or (not (zero? (string-length file)))
  103.                (not (zero? (string-length dir)))))
  104.           (begin
  105.             (with-busy-cursor
  106.              top-level
  107.              (lambda ()
  108.                (send-ftp-request host file dir)
  109.                (popup-information
  110.             top-level "Your FTP request has been mailed.")))))
  111.           (if (not (zero? (string-length rfc)))
  112.           (begin
  113.             (send-rfc-request (string->number rfc 10))
  114.             (popup-information
  115.              top-level
  116.              (string-append "Your FTP request for RFC"
  117.               rfc
  118.               " has been mailed.")))))))
  119.  
  120.    ("Clear" ,(lambda (w)
  121.            (xt:set-values ftp-host-widget    xm:n-value "")
  122.            (xt:set-values ftp-file-widget    xm:n-value "")
  123.            (xt:set-values ftp-dir-widget     xm:n-value "")
  124.            (xt:set-values rfc-number-widget  xm:n-value "")))
  125.  
  126.    ("Exit" ,(lambda (w) (quit)))
  127.  
  128.    ("Help" ,(lambda (w)
  129.           (popup-information
  130.            top-level
  131. "To request a file from an FTP site, fill in the host name and file
  132. name to retrieve and click `OK'.  To get a listing of a directory
  133. on a remote host, fill in the directory name and click `OK'.  You
  134. can combine these to fetch a file and get a directory listing from
  135. one host in a single request.
  136.  
  137. To request a copy of an RFC, fill in the RFC number and click `OK'."
  138. )))
  139.  
  140.    ))
  141.  
  142. (xt:realize-widget top-level)
  143.  
  144. (if (not (defined? vs:top-level))
  145.     (xt:main-loop))
  146.  
  147.